home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / BBS-Archive / Dev / GNU-SMALLTALK.lha / examples / suntool.st < prev    next >
Text File  |  1992-02-15  |  6KB  |  203 lines
  1. "Provide some example interface to SunView.  See the comment in win.c
  2. for details."
  3.  
  4. "======================================================================
  5. |
  6. | Copyright (C) 1990, 1991, 1992 Free Software Foundation, Inc.
  7. | Written by Steve Byrne.
  8. |
  9. | This file is part of GNU Smalltalk.
  10. |
  11. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  12. | under the terms of the GNU General Public License as published by the Free
  13. | Software Foundation; either version 1, or (at your option) any later version.
  14. | 
  15. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  16. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  17. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  18. | details.
  19. | 
  20. | You should have received a copy of the GNU General Public License along with
  21. | GNU Smalltalk; see the file LICENSE.  If not, write to the Free Software
  22. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  23. |
  24.  ======================================================================"
  25.  
  26.  
  27.  
  28. "| pairs |
  29.     pairs _ #((Frame            'FRAME')
  30.           (Panel            'PANEL')
  31.           (PanelMessage    'PANEL_MESSAGE')
  32.           (PanelButton    'PANEL_BUTTON')
  33.           (PanelChoice    'PANEL_CHOICE')
  34.           (PanelSlider    'PANEL_SLIDER')
  35.           (PanelText    'PANEL_TEXT')
  36.           (PanelToggle    'PANEL_TOGGLE')
  37.           (PanelLine    'PANEL_LINE')
  38.          ).
  39.     pairs do:
  40.         [ :aPair | SuntoolObjectTypes at: (aPair at: 1)
  41.                          put: (Smalltalk lookupCAddr: (aPair at: 2)) ]!"
  42.  
  43. Object subclass: #Suntools
  44.     instanceVariableNames: 'stObject'
  45.     classVariableNames: ''
  46.     poolDictionaries: 'SuntoolObjectTypes WindowAttrs'
  47.     category: 'Cool hacking'!
  48.  
  49. Suntools subclass: #Window
  50.     instanceVariableNames: ''
  51.     classVariableNames: ''
  52.     poolDictionaries: ''
  53.     category: 'Cool hacking'.
  54.  
  55. Suntools subclass: #Frame
  56.     instanceVariableNames: ''
  57.     classVariableNames: ''
  58.     poolDictionaries: 'FrameAttrs' "Maybe WindowAttrs too?"
  59.     category: 'Cool hacking'.
  60.  
  61. Suntools subclass: #Panel
  62.     instanceVariableNames: ''
  63.     classVariableNames: ''
  64.     poolDictionaries: 'PanelAttrs'
  65.     category: 'Cool hacking'.
  66.  
  67. Suntools subclass: #PanelItem
  68.     instanceVariableNames: ''
  69.     classVariableNames: ''
  70.     poolDictionaries: 'PanelAttrs'
  71.     category: 'Cool hacking'.
  72.  
  73. Suntools subclass: #Textsw
  74.     instanceVariableNames: ''
  75.     classVariableNames: ''
  76.     poolDictionaries: 'TextswAttrs'
  77.     category: 'Cool hacking'.
  78.  
  79. Suntools subclass: #Canvas
  80.     instanceVariableNames: ''
  81.     classVariableNames: ''
  82.     poolDictionaries: 'CanvasAttrs'
  83.     category: 'Cool hacking'.
  84.  
  85. Suntools subclass: #Develop
  86.     instanceVariableNames: ''
  87.     classVariableNames: ''
  88.     poolDictionaries: 'CanvasAttrs TextswAttrs PanelAttrs FrameAttrs SuntoolObjectTypes WindowAttrs'
  89.     category: 'Cool hacking'!
  90.  
  91.  
  92. 'about to create a window' printNl!
  93.  
  94. Behavior defineCFunc: 'windowCreate'
  95.          withSelectorArgs: 'windowCreate: parent type: aType attrs: anArray'
  96.      forClass: Suntools class
  97.      returning: #cObject
  98.      args: #(cObject cObject variadic)
  99. !
  100.  
  101. !Suntools class methodsFor: 'instance creation'!
  102.  
  103. createWindowObject: parent type: objectType attrs: anArray
  104.     | parentObject |
  105.     parentObject _ parent isNil ifTrue:  [ nil ]
  106.                             ifFalse: [ parent stObject ].
  107.     ^self newObject: (self windowCreate: parentObject type: objectType attrs: anArray)
  108. !
  109.  
  110. newObject: suntoolsObject
  111.     ^(self new) stObject: suntoolsObject
  112. !!
  113.  
  114.  
  115. !Suntools methodsFor: 'private'!
  116.  
  117. stObject
  118.     ^stObject
  119. !
  120.  
  121. stObject: suntoolsObject
  122.     stObject _ suntoolsObject
  123. !!
  124.  
  125.  
  126. Behavior defineCFunc: 'windowLoop'
  127.          withSelectorArgs: 'windowLoop: frame'
  128.          forClass: Frame
  129.      returning: #void
  130.      args: #(cObject)
  131. !
  132.  
  133. !Frame class methodsFor: 'instance creation'!
  134.  
  135. create: parent attributes: anArray
  136.     ^self createWindowObject: parent type: FrameType attrs: anArray
  137. !!
  138.  
  139. !Frame methodsFor: 'processing'!
  140.  
  141. windowMainLoop
  142.     self windowLoop: stObject
  143. !!
  144.  
  145. !Panel class methodsFor: 'instance creation'!
  146.  
  147. create: parent attributes: anArray
  148.     ^self createWindowObject: parent type: PanelType attrs: anArray
  149. !!
  150.  
  151. Behavior defineCFunc: 'panelCreateItem'
  152.          withSelectorArgs: 'panelCreateItem: panel type: aType attrs: anArray'
  153.      forClass: Panel
  154.      returning: #cObject
  155.      args: #(cObject cObject variadic)!
  156.  
  157. !Panel methodsFor: 'processing'!
  158.  
  159. createItem: type attributes: anArray
  160.     "not right"
  161.     ^self panelCreateItem: stObject type: type attrs: anArray
  162. !!    
  163.  
  164. !Develop class methodsFor: 'test'!
  165.  
  166. test
  167. | frame aStream panel |
  168.     aStream _ WriteStream on: (Array new: 0).
  169.     aStream nextPut: frameLabel.  aStream nextPut: 'Test window'.
  170.     aStream nextPut: 0.
  171.     frame _ Frame create: nil attributes: aStream contents.
  172.     aStream _ WriteStream on: (Array new: 3).
  173.     aStream nextPut: panelLayout.
  174.     aStream nextPut: (Smalltalk lookupCAddr: 'PANEL_VERTICAL').
  175.     aStream nextPut: 0.
  176.     panel _ Panel create: frame attributes: aStream contents.
  177.     
  178.  
  179.     aStream _ WriteStream on: (Array new: 0).
  180.     aStream nextPut: panelLabelString.
  181.     aStream nextPut: 'Rambo'.
  182.     aStream nextPut: panelChoiceStrings.
  183.         aStream nextPut: 'foo'.
  184.         aStream nextPut: 'bar'.
  185.         aStream nextPut: 'baz'.
  186.     aStream nextPut: 0.
  187.     aStream nextPut: 0.
  188.     panel createItem: PanelChoiceType attributes: aStream contents.    
  189.  
  190.     aStream _ WriteStream on: (Array new: 0).
  191.     aStream nextPut: panelLabelString.    aStream nextPut: 'Brightness: '.
  192.     aStream nextPut: panelValue.          aStream nextPut: 75.
  193.     aStream nextPut: panelMinValue.       aStream nextPut: 0. 
  194.     aStream nextPut: panelMaxValue.       aStream nextPut: 100.
  195.     aStream nextPut: panelSliderWidth.      aStream nextPut: 300.
  196.     panel createItem: PanelSliderType attributes: aStream contents.
  197.     frame windowMainLoop
  198. !!
  199.  
  200. Develop test!
  201.  
  202.  
  203.